* slash characters are replaced by '_' so the equivalent name for 'show/qth'
is 'Emb_show_qth'.
-* you would normally do a 'my $self = shift;' as the first thing. There
+* you would normally do a 'my ($self, $line) = @_;' as the first thing. There
are a complete set of accessors for DXUser, DXCommandmode and DXChannel
classes and these are the recommended way of getting at these classes.
A fairly standard start might be:-
- $self = shift;
+ my ($self, $line) = @_;
+ @args = split /\s+/, $line;
$call = $self->call;
$user = $self->user;
of an element (the client will put the correct one in if required
[but see below]).
+* As this is perl and it is very easy to alter stuff to get it correct,
+ I would like to see some intelligent argument processing, e.g. if
+ you can have one callsign, you can have several. Interpret your
+ arguments; so for example:-
+
+ set/locator jo02lq - sets your own locator to JO02LQ
+ set/locator g1tlh jo02lq - sets G1TLH's locator (if you are allowed)
+
+ or
+
+ show/locator - displays your locator (and other info?)
+ show/locator in92jo - displays the bearing and distance to
+ IN92JO using your lat/long or locator
+ show/locator jn56in in92jo - bearing and distance between two
+ locators
+ show/locator gb7dxc - bearing and distance to gb7dxc if poss.
+
* Anything you output with a > as the last character is taken to mean
that this is a prompt and will not have a \r or \n appended to it.
+#
+# set the announce flag
+#
+# Copyright (c) 1998 - Dirk Koopman
+#
+# $Id$
+#
+
+my ($self, $line) = @_;
+my @args = split /\s+/, $line;
+my $call;
+my @out;
+
+@args = $self->call if (!@args || $self->priv < 9);
+
+foreach $call (@args) {
+ $call = uc $call;
+ my $user = ($call eq $self->call) ? $self->user : DXUser->get($call);
+ if ($user) {
+ $user->ann(1);
+ push @out, DXM::msg('anns', $call);
+ } else {
+ push @out, DXM::msg('e3', "Set Announce", $call);
+ }
+}
+return (1, @out);
# $Id$
#
-use DXDebug;
-
-$self = shift;
+my ($self, $line) = @_;
return (0) if $self->priv < 9;
-dbgadd(split);
+dbgadd(split /\s+/, $line);
my $set = join ' ', dbglist();
return (1, "Debug Levels now: $set");
+#
+# set the dx flag
+#
+# Copyright (c) 1998 - Dirk Koopman
+#
+# $Id$
+#
+
+my ($self, $line) = @_;
+my @args = split /\s+/, $line;
+my $call;
+my @out;
+
+@args = $self->call if (!@args || $self->priv < 9);
+
+foreach $call (@args) {
+ $call = uc $call;
+ my $user = ($call eq $self->call) ? $self->user : DXUser->get($call);
+ if ($user) {
+ $user->dx(1);
+ push @out, DXM::msg('dxs', $call);
+ } else {
+ push @out, DXM::msg('e3', "Set DX Spots", $call);
+ }
+}
+return (1, @out);
+#
+# set the here flag
+#
+# Copyright (c) 1998 - Dirk Koopman
+#
+# $Id$
+#
+
+my ($self, $line) = @_;
+my @args = split /\s+/, $line;
+my $call;
+my @out;
+
+@args = $self->call if (!@args || $self->priv < 9);
+
+foreach $call (@args) {
+ $call = uc $call;
+ my $user = ($call eq $self->call) ? $self->user : DXUser->get($call);
+ if ($user) {
+ $user->here(1);
+ push @out, DXM::msg('heres', $call);
+ } else {
+ push @out, DXM::msg('e3', "Set Here", $call);
+ }
+}
+return (1, @out);
+#
+# set the talk flag
+#
+# Copyright (c) 1998 - Dirk Koopman
+#
+# $Id$
+#
+
+my ($self, $line) = @_;
+my @args = split /\s+/, $line;
+my $call;
+my @out;
+
+@args = $self->call if (!@args || $self->priv < 9);
+
+foreach $call (@args) {
+ $call = uc $call;
+ my $user = ($call eq $self->call) ? $self->user : DXUser->get($call);
+ if ($user) {
+ $user->talk(1);
+ push @out, DXM::msg('talks', $call);
+ } else {
+ push @out, DXM::msg('e3', "Set Talk", $call);
+ }
+}
+return (1, @out);
+#
+# set the wwv flag
+#
+# Copyright (c) 1998 - Dirk Koopman
+#
+# $Id$
+#
+
+my ($self, $line) = @_;
+my @args = split /\s+/, $line;
+my $call;
+my @out;
+
+@args = $self->call if (!@args || $self->priv < 9);
+
+foreach $call (@args) {
+ $call = uc $call;
+ my $user = ($call eq $self->call) ? $self->user : DXUser->get($call);
+ if ($user) {
+ $user->wwv(1);
+ push @out, DXM::msg('wwvs', $call);
+ } else {
+ push @out, DXM::msg('e3', "Set WWV", $call);
+ }
+}
+return (1, @out);
# $Id$
#
-my $self = shift;
-#return (0) if ($self->priv < 9); # only console users allowed
-my @list = split; # generate a list of callsigns
-@list = ($self->call) if !@list; # my channel if no callsigns
+my ($self, $line) = @_;
+my @list = /\s+/, $line; # generate a list of callsigns
+@list = ($self->call) if (!@list || $self->priv < 9); # my channel if no callsigns
my $call;
my @out;
foreach $call (@list) {
+ $call = uc $call;
my $ref = DXChannel->get($call);
- return (0, "Channel: $call not found") if !$ref;
-
- my @fields = $ref->fields;
- my $field;
- push @out, "User Information $call";
- foreach $field (@fields) {
- my $prompt = $ref->field_prompt($field);
- my $val = $ref->{$field};
- push @out, "$prompt: $val";
- }
+ if ($ref) {
+ @out = print_all_fields($self, $ref, "Channe Information $call");
+ } else {
+ return (0, "Channel: $call not found") if !$ref;
+ }
+ push @out, "" if @list > 1;
}
return (1, @out);
# $Id$
#
-my $self = shift;
-#return (0) if ($self->priv < 9); # only console users allowed
-my @list = split; # generate a list of callsigns
+my ($self, $line) = @_;
+my @list = split /\s+/, $line; # generate a list of callsigns
@list = ($self->call) if !@list; # my channel if no callsigns
my $call;
my @out;
foreach $call (@list) {
+ $call = uc $call;
my $ref = DXUser->get($call);
- return (0, "User: $call not found") if !$ref;
-
- my @fields = $ref->fields;
- my $field;
- push @out, "User Information $call";
- foreach $field (@fields) {
- my $prompt = $ref->field_prompt($field);
- my $val = $ref->{$field};
- push @out, "$prompt: $val";
- }
+ if ($ref) {
+ @out = print_all_fields($self, $ref, "User Information $call");
+ } else {
+ push @out, "User: $call not found";
+ }
+ push @out, "" if @list > 1;
}
return (1, @out);
-
-
-
-
+#
+# unset the announce flag
+#
+# Copyright (c) 1998 - Dirk Koopman
+#
+# $Id$
+#
+
+my ($self, $line) = @_;
+my @args = split /\s+/, $line;
+my $call;
+my @out;
+
+@args = $self->call if (!@args || $self->priv < 9);
+
+foreach $call (@args) {
+ $call = uc $call;
+ my $user = ($call eq $self->call) ? $self->user : DXUser->get($call);
+ if ($user) {
+ $user->ann(0);
+ push @out, DXM::msg('annu', $call);
+ } else {
+ push @out, DXM::msg('e3', "Unset Announce", $call);
+ }
+}
+return (1, @out);
#
-# add a debug level
+# remove a debug level
+#
+# Copyright (c) 1998 - Dirk Koopman
#
# $Id$
#
-use DXDebug;
-
-$self = shift;
+my ($self, $line) = @_;
return (0) if $self->priv < 9;
-dbgsub(split);
+dbgsub(split /\s+/, $line);
my $set = join ' ', dbglist();
return (1, "Debug Levels now: $set");
+#
+# unset the dx flag
+#
+# Copyright (c) 1998 - Dirk Koopman
+#
+# $Id$
+#
+
+my ($self, $line) = @_;
+my @args = split /\s+/, $line;
+my $call;
+my @out;
+
+@args = $self->call if (!@args || $self->priv < 9);
+
+foreach $call (@args) {
+ $call = uc $call;
+ my $user = ($call eq $self->call) ? $self->user : DXUser->get($call);
+ if ($user) {
+ $user->dx(0);
+ push @out, DXM::msg('dxu', $call);
+ } else {
+ push @out, DXM::msg('e3', "Unset DX Spots", $call);
+ }
+}
+return (1, @out);
+#
+# unset the here flag
+#
+# Copyright (c) 1998 - Dirk Koopman
+#
+# $Id$
+#
+
+my ($self, $line) = @_;
+my @args = split /\s+/, $line;
+my $call;
+my @out;
+
+@args = $self->call if (!@args || $self->priv < 9);
+
+foreach $call (@args) {
+ $call = uc $call;
+ my $user = ($call eq $self->call) ? $self->user : DXUser->get($call);
+ if ($user) {
+ $user->here(0);
+ push @out, DXM::msg('hereu', $call);
+ } else {
+ push @out, DXM::msg('e3', "Unset Here", $call);
+ }
+}
+return (1, @out);
+#
+# unset the talk flag
+#
+# Copyright (c) 1998 - Dirk Koopman
+#
+# $Id$
+#
+
+my ($self, $line) = @_;
+my @args = split /\s+/, $line;
+my $call;
+my @out;
+
+@args = $self->call if (!@args || $self->priv < 9);
+
+foreach $call (@args) {
+ $call = uc $call;
+ my $user = ($call eq $self->call) ? $self->user : DXUser->get($call);
+ if ($user) {
+ $user->talk(0);
+ push @out, DXM::msg('talku', $call);
+ } else {
+ push @out, DXM::msg('e3', "Unset Talk", $call);
+ }
+}
+return (1, @out);
+#
+# unset the wwv flag
+#
+# Copyright (c) 1998 - Dirk Koopman
+#
+# $Id$
+#
+
+my ($self, $line) = @_;
+my @args = split /\s+/, $line;
+my $call;
+my @out;
+
+@args = $self->call if (!@args || $self->priv < 9);
+
+foreach $call (@args) {
+ $call = uc $call;
+ my $user = ($call eq $self->call) ? $self->user : DXUser->get($call);
+ if ($user) {
+ $user->wwv(0);
+ push @out, DXM::msg('wwvu', $call);
+ } else {
+ push @out, DXM::msg('e3', "Unset WWV", $call);
+ }
+}
+return (1, @out);
%channels = undef;
%valid = (
- call => 'Callsign',
- conn => 'Msg Connection ref',
- user => 'DXUser ref',
- t => 'Time',
- priv => 'Privilege',
- state => 'Current State',
- oldstate => 'Last State',
- list => 'Dependant DXChannels list',
- name => 'User Name',
- connsort => 'Connection Type'
+ call => '0,Callsign',
+ conn => '9,Msg Conn ref',
+ user => '9,DXUser ref',
+ t => '0,Time,atime',
+ priv => '9,Privilege',
+ state => '0,Current State',
+ oldstate => '5,Last State',
+ list => '9,Dep Chan List',
+ name => '0,User Name',
+ consort => '9,Connection Type'
);
}
%valid = (
- mynode => 'Parent Node',
- call => 'Callsign',
- confmode => 'Conference Mode',
- here => 'Here?',
- dxprot => 'Channel ref',
- version => 'Node Version',
+ mynode => '0,Parent Node',
+ call => '0,Callsign',
+ confmode => '5,Conference Mode,yesno',
+ here => '5,Here?,yesno',
+ dxprot => '5,Channel ref',
+ version => '5,Node Version',
);
+# return a prompt for a field
+sub field_prompt
+{
+ my ($self, $ele) = @_;
+ return $valid{$ele};
+}
+
sub AUTOLOAD
{
my $self = shift;
my ($self, $line) = @_;
my $user = $self->{user};
my $call = $self->{call};
- my $name = $self->{name};
- $name = $call if !defined $name;
+ my $name = $user->{name};
- $self->msg('l2',$name);
+ $self->{name} = $name ? $name : $call;
+ $self->msg('l2',$self->{name});
$self->send_file($main::motd) if (-e $main::motd);
$self->msg('pr', $call);
$self->state('prompt'); # a bit of room for further expansion, passwords etc
@EXPORT = qw(msg);
%msgs = (
+ addr => 'Address set to: $_[0]',
+ anns => 'Announce flag set on $_[0]',
+ annu => 'Announce flag unset on $_[0]',
+ conother => 'Sorry $_[0] you are connected on another port',
+ concluster => 'Sorry $_[0] you are already connected elsewhere on the cluster',
+ dxs => 'DX Spots flag set on $_[0]',
+ dxu => 'DX Spots flag unset on $_[0]',
+ e1 => 'Invalid command',
+ e2 => 'Error: $_[0]',
+ e3 => '$_[0]: $_[1] not found',
+ email => 'E-mail address set to: $_[0]',
+ heres => 'Here set on $_[0]',
+ hereu => 'Here unset on $_[0]',
+ homebbs => 'Home BBS set to: $_[0]',
+ homenode => 'Home Node set to: $_[0]',
l1 => 'Sorry $_[0], you are already logged on on another channel',
l2 => 'Hello $_[0], this is $main::mycall located in $main::myqth',
+ m2 => '$_[0] Information: $_[1]',
pr => '$_[0] de $main::mycall $main::cldate $main::ztime >',
- e1 => 'Invalid command',
- e2 => 'Error: $_[0]',
- conother => 'Sorry $_[0] you are connected on another port',
- concluster => 'Sorry $_[0] you are already connected elsewhere on the cluster',
+ prx => '$main::$mycall >',
+ talks => 'Talk flag set on $_[0]',
+ talku => 'Talk flag unset on $_[0]',
+ wwvs => 'WWV flag set on $_[0]',
+ wwvu => 'WWV flag unset on $_[0]',
);
sub msg
my $self = shift;
my $s = $msgs{$self};
return "unknown message '$self'" if !defined $s;
-
- return eval '"'. $s . '"';
+ return eval qq("$s");
}
my $call = $self->call;
# do we have him connected on the cluster somewhere else?
- if (DXCluster->get
$self->pc38();
$self->pc18();
$self->{state} = 'incoming';
# All the various PC routines
#
+sub pc18
+{
+
+}
+
+sub pc38
+{
+
+}
+
+
1;
__END__
# hash of valid elements and a simple prompt
%valid = (
- call => 'Callsign',
- alias => 'Real Callsign',
- name => 'Name',
- qth => 'Home QTH',
- lat => 'Latitude',
- long => 'Longtitude',
- qra => 'Locator',
- email => 'E-mail Address',
- priv => 'Privilege Level',
- lastin => 'Last Time in',
- passwd => 'Password',
- addr => 'Full Address',
- 'sort' => 'Type of User', # A - ak1a, U - User, S - spider cluster, B - BBS
+ call => '0,Callsign',
+ alias => '0,Real Callsign',
+ name => '0,Name',
+ qth => '0,Home QTH',
+ lat => '0,Latitude,slat',
+ long => '0,Longitude,slong',
+ qra => '0,Locator',
+ email => '0,E-mail Address',
+ priv => '9,Privilege Level',
+ lastin => '0,Last Time in,cldatetime',
+ passwd => '9,Password',
+ addr => '0,Full Address',
+ sort => '0,Type of User', # A - ak1a, U - User, S - spider cluster, B - BBS
+ wwv => '0,Want WWV,yesno',
+ talk => '0,Want Talk,yesno',
+ ann => '0,Want Announce,yesno',
+ here => '0,Here Status,yesno',
+ xpert => '0,Expert Status,yesno',
+ bbs => '0,Home BBS',
+ node => '0,Home Node',
+ dx => '0,DX Spots,yesno',
);
sub AUTOLOAD
$name =~ s/.*:://o;
die "Non-existant field '$AUTOLOAD'" if !$valid{$name};
- @_ ? $self->{$name} = shift : $self->{$name} ;
+ if (@_) {
+ $self->{$name} = shift;
+ $self->put();
+ }
+ return $self->{$name};
}
#
require Exporter;
@ISA = qw(Exporter);
-@EXPORT = qw(atime ztime cldate
+@EXPORT = qw(atime ztime cldate cldatetime slat slong yesno promptf
+ print_all_fields
);
@month = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
return $buf;
}
+# return a cluster style date time
+sub cldatetime
+{
+ my $t = shift;
+ my $date = cldate($t);
+ my $time = ztime($t);
+ return "$date $time";
+}
+
+# turn a latitude in degrees into a string
+sub slat
+{
+ my $n = shift;
+ my ($deg, $min, $let);
+ $let = $n >= 0 ? 'N' : 'S';
+ $n = abs $n;
+ $deg = int $n;
+ $min = int (($n - $deg) * 60);
+ return "$deg $min $let";
+}
+# turn a longitude in degrees into a string
+sub slong
+{
+ my $n = shift;
+ my ($deg, $min, $let);
+ $let = $n >= 0 ? 'E' : 'W';
+ $n = abs $n;
+ $deg = int $n;
+ $min = int (($n - $deg) * 60);
+ return "$deg $min $let";
+}
+
+# turn a true into 'yes' and false into 'no'
+sub yesno
+{
+ my $n = shift;
+ return $n ? $main::yes : $main::no;
+}
+
+# format a prompt with its current value and return it with its privilege
+sub promptf
+{
+ my ($line, $value) = @_;
+ my ($priv, $prompt, $action) = split ',', $line;
+
+ # if there is an action treat it as a subroutine and replace $value
+ if ($action) {
+ my $q = qq{\$value = $action(\$value)};
+ eval $q;
+ }
+ $prompt = sprintf "%15s: %s", $prompt, $value;
+ return ($priv, $prompt);
+}
+
+# print all the fields for a record according to privilege
+#
+# The prompt record is of the format '<priv>,<prompt>[,<action>'
+# and is expanded by promptf above
+#
+sub print_all_fields
+{
+ my $self = shift; # is a dxchan
+ my $ref = shift; # is a thingy with field_prompt and fields methods defined
+ my @out = @_;
+
+ my @fields = $ref->fields;
+ my $field;
+ my @out;
+
+ foreach $field (sort @fields) {
+ my ($priv, $ans) = promptf($ref->field_prompt($field), $ref->{$field});
+ push @out, $ans if ($self->priv >= $priv);
+ }
+ return @out;
+}
# the version of DX cluster (tm) software I am masquerading as
$myprot = "5447";
+# your favorite way to say 'Yes'
+$yes = 'Yes';
+
+# your favorite way to say 'No'
+$no = 'No';
+
# default hopcount to use - note this will override any incoming hop counts, if they are greater
$def_hopcount = 7;
$call = uc $mycall if !$call;
$connsort = lc shift @ARGV;
$connsort = 'local' if !$connsort;
-$mode = ($connsort =~ /^ax/) ? 1 : 2;
+$mode = ($connsort =~ /^ax/o) ? 1 : 2;
setmode();
#select STDOUT; $| = 1;
$conn = Msg->connect("$clusteraddr", $clusterport, \&rec_socket);
$conn->send_now("A$call|$connsort");
Msg->set_event_handler(\*STDIN, "read" => \&rec_stdin);
-Msg->event_loop();
+
+$lasttime = time;
+for (;;) {
+ my $t;
+ Msg->event_loop(1, 0.010);
+ $t = time;
+ if (t > $lasttime+660 && $connsort =~ /^ax/o) { # every e
+ print pack('xx');
+ STDOUT->fflush();
+ $lasttime = $t;
+ }
+}
if (!defined $dxchan) {
my ($sort, $call, $line) = $msg =~ /^(\w)(\S+)\|(.*)$/;
my $user = DXUser->get($call);
- $user = DXUser->new($call) if !defined $user;
- $user->sort('U') if (!$user->sort());
+ if (!defined $user) {
+ $user = DXUser->new($call);
+ }
my $sort = $user->sort();
# is there one already connected?
return;
}
+ # set some necessary flags on the user if they are connecting
+ $user->wwv(1) if !$user->wwv();
+ $user->talk(1) if !$user->talk();
+ $user->ann(1) if !$user->ann();
+ $user->here(1) if !$user->here();
+ $user->sort('U') if !$user->sort();
+
# create the channel
$dxchan = DXCommandmode->new($call, $conn, $user) if ($sort eq 'U');
$dxchan = DXProt->new($call, $conn, $user) if ($sort eq 'A');
projects / spider.git / commitdiff