From: djk Date: Mon, 17 Aug 1998 00:34:39 +0000 (+0000) Subject: sh/dx and sh/dxcc now fully implemented X-Git-Tag: SPIDER_1_5~41 X-Git-Url: http://dxcluster.org/gitweb/gitweb.cgi?a=commitdiff_plain;h=e5b0e3dee551a224de284a5ba550098256fcb268;p=spider.git sh/dx and sh/dxcc now fully implemented abbreviated commands now work automagically band data now implemented and working --- diff --git a/cmd/show/dx.pl b/cmd/show/dx.pl index e69de29b..e3d3aed2 100644 --- a/cmd/show/dx.pl +++ b/cmd/show/dx.pl @@ -0,0 +1,116 @@ +# +# show dx (normal) +# +# $Id$ +# + +my ($self, $line) = @_; +my @list = split /\s+/, $line; # split the line up + +my @out; +my $f; +my $call; +my ($from, $to); +my ($fromday, $today); +my @freq; +my @ans; +my $pre; +my $spotter; +my $info; +my $expr; + +while ($f = shift @list) { # next field + print "f: $f list: ", join(',', @list), "\n"; + if (!$from && !$to) { + ($from, $to) = $f =~ /^(\d+)-(\d+)$/o; # is it a from -> to count? + next if $from && $to > $from; + } + if (!$to) { + ($to) = $f =~ /^(\d+)$/o if !$to; # is it a to count? + next if $to; + } + if (lc $f eq 'on' && $list[0]) { # is it freq range? + print "yup freq\n"; + my @r = split '/', $list[0]; + print "r0: $r[0] r1: $r[1]\n"; + @freq = Bands::get_freq($r[0], $r[1]); + if (@freq) { # yup, get rid of extranous param + print "freq: ", join(',', @freq), "\n"; + shift @list; + next; + } + } + if (lc $f eq 'day' && $list[0]) { + print "got day\n"; + ($fromday, $today) = split '-', shift(@list); + next; + } + if (lc $f eq 'info' && $list[0]) { + print "got info\n"; + $info = shift @list; + next; + } + if (lc $f eq 'spotter' && $list[0]) { + print "got spotter\n"; + $spotter = uc shift @list; + next; + } + if (!$pre) { + $pre = uc $f; + } +} + +# first deal with the prefix +if ($pre) { + $expr = "\$f1 =~ /"; + $pre =~ s|/|\\/|; # change the slashes to \/ + if ($pre =~ /^\*/o) { + $pre =~ s/^\*//;; + $expr .= "$pre\$/o"; + } else { + $expr .= "^$pre/o"; + } +} else { + $expr = "1"; # match anything +} + +# now deal with any frequencies specified +if (@freq) { + $expr .= ($expr) ? " && (" : "("; + my $i; + for ($i; $i < @freq; $i += 2) { + $expr .= "(\$f0 >= $freq[0] && \$f0 <= $freq[1]) ||"; + } + chop $expr; + chop $expr; + $expr .= ")"; +} + +# any info +if ($info) { + $expr .= " && " if $expr; + $info =~ s|/|\\/|; + $expr .= "\$f3 =~ /$info/io"; +} + +# any spotter +if ($spotter) { + $expr .= " && " if $expr; + $spotter =~ s|/|\\/|; + $expr .= "\$f4 =~ /$spotter/o"; +} + +print "expr: $expr from: $from to: $to fromday: $fromday today: $today\n"; + +# now do the search +my @res = Spot::search($expr, $fromday, $today, $from, $to); +my $ref; +my @dx; +foreach $ref (@res) { + @dx = @$ref; + my $t = ztime($dx[2]); + my $d = cldate($dx[2]); + push @out, sprintf "%9s %-12s %s %s %-28s <%s>", $dx[0], $dx[1], $d, $t, $dx[3], $dx[4]; +} + +return (1, @out); diff --git a/cmd/show/dxcc.pl b/cmd/show/dxcc.pl index f18eaef9..b95bb7fe 100644 --- a/cmd/show/dxcc.pl +++ b/cmd/show/dxcc.pl @@ -5,23 +5,61 @@ # my ($self, $line) = @_; -my @list = split /\s+/, $line; # generate a list of callsigns +my @list = split /\s+/, $line; # split the line up -my $l; my @out; +my $f; +my $call; +my ($from, $to); +my ($fromday, $today); +my @freq; +my @ans; -print "line: $line\n"; -foreach $l (@list) { - my @ans = Prefix::extract($l); - print "ans:", @ans, "\n"; - next if !@ans; +while ($f = shift @list) { # next field + print "f: $f list: ", join(',', @list), "\n"; + if (!$from && !$to) { + ($from, $to) = $f =~ /^(\d+)-(\d+)$/o; # is it a from -> to count? + next if $from && $to > $from; + } + if (!$to) { + ($to) = $f =~ /^(\d+)$/o if !$to; # is it a to count? + next if $to; + } + if (lc $f eq 'on' && $list[0]) { # is it freq range? + print "yup freq\n"; + my @r = split '/', $list[0]; + print "r0: $r[0] r1: $r[1]\n"; + @freq = Bands::get_freq($r[0], $r[1]); + if (@freq) { # yup, get rid of extranous param + print "freq: ", join(',', @freq), "\n"; + shift @list; + next; + } + } + if (lc $f eq 'day' && $list[0]) { + print "got day\n"; + ($fromday, $today) = split '-', $list[0]; + shift @list; + next; + } + if (!@ans) { + @ans = Prefix::extract($f); # is it a callsign/prefix? + } +} + +# no dxcc country, no answer! +if (@ans) { # we have a valid prefix! + + # first deal with the prefix my $pre = shift @ans; my $a; - my $expr; + my $expr = "("; my $str = "Prefix: $pre"; my $l = length $str; + + # build up a search string for this dxcc country/countries foreach $a (@ans) { - $expr .= " || " if $expr; + $expr .= " || " if $expr ne "("; my $n = $a->dxcc(); $expr .= "\$f5 == $n"; my $name = $a->name(); @@ -29,9 +67,25 @@ foreach $l (@list) { push @out, $str; $str = pack "A$l", " "; } + $expr .= ")"; push @out, $str; - print "expr: $expr\n"; - my @res = Spot::search($expr); + + # now deal with any frequencies specified + if (@freq) { + $expr .= " && ("; + my $i; + for ($i; $i < @freq; $i += 2) { + $expr .= "(\$f0 >= $freq[0] && \$f0 <= $freq[1]) ||"; + } + chop $expr; + chop $expr; + $expr .= ")"; + } + + print "expr: $expr from: $from to: $to fromday: $fromday today: $today\n"; + + # now do the search + my @res = Spot::search($expr, $fromday, $today, $from, $to); my $ref; my @dx; foreach $ref (@res) { @@ -40,6 +94,8 @@ foreach $l (@list) { my $d = cldate($dx[2]); push @out, sprintf "%9s %-12s %s %s %-28s <%s>", $dx[0], $dx[1], $d, $t, $dx[3], $dx[4]; } +} else { + @out = DXM::msg('e4'); } return (1, @out); diff --git a/perl/Bands.pm b/perl/Bands.pm new file mode 100644 index 00000000..99612693 --- /dev/null +++ b/perl/Bands.pm @@ -0,0 +1,124 @@ +# +# module to manage the band list +# +# Copyright (c) 1998 - Dirk Koopman G1TLH +# +# $Id$ +# + +package Bands; + +use DXUtil; +use DXDebug; +use DXVars; +use Carp; + +use strict; +use vars qw(%bands %regions $bandsfn %valid); + +%bands = (); # the 'raw' band data +%regions = (); # list of regions for shortcuts eg vhf ssb +$bandsfn = "$main::data/bands.pl"; + +%valid = ( + cw => '0,CW,parraypairs', + ssb => '0,SSB,parraypairs', + data => '0,DATA,parraypairs,parraypairs', + sstv => '0,SSTV,parraypairs', + fstv => '0,FSTV,parraypairs', + rtty => '0,RTTY,parraypairs', + pactor => '0,PACTOR,parraypairs', + packet => '0,PACKET,parraypairs', + repeater => '0,REPEATER,parraypairs', + fax => '0,FAX,parraypairs', + beacon => '0,BEACON,parraypairs', + band => '0,BAND,parraypairs', +); + +# load the band data +sub load +{ + %bands = (); + do $bandsfn; + confess $@ if $@; +} + +# obtain a band object by callsign [$obj = Band::get($call)] +sub get +{ + my $call = shift; + return $bands{$call}; +} + +# obtain all the band objects +sub get_all +{ + return values(%bands); +} + +# get all the band keys +sub get_keys +{ + return keys(%bands); +} + +# get all the frequency pairs associated with the band and sub-band offered +# the band can be a region, sub-band can be missing +# +# called Bands::get_freq(band-label, subband-label) +sub get_freq +{ + my ($band, $subband) = @_; + my @band; + my $b; + my @out; + return () if !$band; + $subband = 'band' if !$subband; + + # first look in the region + $b = $regions{$band}; + @band = @$b if $b; + @band = ($band) if @band == 0; + + # we now have a list of bands to scan for sub bands + foreach $b (@band) { + my $wb = $bands{$b}; + if ($wb) { + my $sb = $wb->{$subband}; + push @out, @$sb if $sb; + } + } + return @out; +} + +# +# return a list of valid elements +# + +sub fields +{ + return keys(%valid); +} + +# +# return a prompt for a field +# + +sub field_prompt +{ + my ($self, $ele) = @_; + return $valid{$ele}; +} + +no strict; +sub AUTOLOAD +{ + my $self = shift; + my $name = $AUTOLOAD; + return if $name =~ /::DESTROY$/; + $name =~ s/.*:://o; + + @_ ? $self->{$name} = shift : $self->{$name} ; +} + +1; diff --git a/perl/DXCommandmode.pm b/perl/DXCommandmode.pm index 474d2c9c..9f7b3885 100644 --- a/perl/DXCommandmode.pm +++ b/perl/DXCommandmode.pm @@ -16,13 +16,14 @@ use DXChannel; use DXUser; use DXVars; use DXDebug; +use DXM; +use Carp; use strict; +use vars qw(%Cache %cmd_cache); -#use vars qw( %Cache $last_dir_mtime @cmd); -my %Cache = (); # cache of dynamically loaded routine's mod times -my $last_dir_mtime = 0; # the last time one of the cmd dirs was modified -my @cmd = undef; # a list of commands+path pairs (in alphabetical order) +%Cache = (); # cache of dynamically loaded routine's mod times +%cmd_cache = (); # cache of short names # # obtain a new connection this is derived from dxchannel @@ -57,6 +58,7 @@ sub start # set some necessary flags on the user if they are connecting $self->{wwv} = $self->{talk} = $self->{ann} = $self->{here} = $self->{dx} = 1; + $self->prompt() if $self->{state} =~ /^prompt/o; } @@ -68,7 +70,7 @@ sub normal my $self = shift; my $user = $self->{user}; my $call = $self->{call}; - my $cmdline = shift; + my $cmdline = shift; # strip out // $cmdline =~ s|//|/|og; @@ -77,12 +79,15 @@ sub normal my ($cmd, $args) = $cmdline =~ /^([\w\/]+)\s*(.*)/o; if ($cmd) { - + + my ($path, $fcmd); + # first expand out the entry to a command - $cmd = search($cmd); + ($path, $fcmd) = search($main::localcmd, $cmd, "pl"); + ($path, $fcmd) = search($main::cmd, $cmd, "pl") if !$path || !$fcmd; - my @ans = $self->eval_file($main::localcmd, $cmd, $args); - @ans = $self->eval_file($main::cmd, $cmd, $args) if !$ans[0]; + my @ans = $self->eval_file($path, $fcmd, $args) if $path && $fcmd; +# @ans = $self->eval_file($main::cmd, $cmd, $args) if !$ans[0]; if ($ans[0]) { shift @ans; $self->send(@ans) if @ans > 0; @@ -178,10 +183,63 @@ sub get_all sub search { - my $short_cmd = shift; - return $short_cmd; # just return it for now + my ($path, $short_cmd, $suffix) = @_; + my ($apath, $acmd); + + # commands are lower case + $short_cmd = lc $short_cmd; + dbg('command', "command: $path $short_cmd\n"); + + # return immediately if we have it + my ($apath, $acmd) = split ',', $cmd_cache{$short_cmd}; + if ($apath && $acmd) { + dbg('command', "cached $short_cmd = ($apath, $acmd)\n"); + return ($apath, $acmd) if $apath; + } + + # if not guess + my @parts = split '/', $short_cmd; + my $dirfn; + my $curdir = $path; + my $p; + my $i; + + for ($i = 0; $i < @parts; $i++) { + my $p = $parts[$i]; + opendir(D, $curdir) or confess "can't open $curdir $!"; + my @ls = readdir D; + closedir D; + my $l; + foreach $l (sort @ls) { + next if $l =~ /^\./; + if ($i < $#parts) { # we are dealing with directories + if ((-d "$curdir/$l") && $p eq substr($l, 0, length $p)) { + dbg('command', "got dir: $curdir/$l\n"); + $dirfn .= "$l/"; + $curdir .= "/$l"; + last; + } + } else { # we are dealing with commands + next if !$l =~ /\.$suffix$/; # only look for .$suffix files + if ($p eq substr($l, 0, length $p)) { + $l =~ s/\.$suffix$//; # remove the suffix + chop $dirfn; # remove trailing / + $cmd_cache{"$short_cmd"} = join(',', ($path, "$dirfn/$l")); # cache it + dbg('command', "got path: $path cmd: $dirfn/$l\n"); + return ($path, "$dirfn/$l"); + } + } + } + } + return (); } +# clear the command name cache +sub clear_cmd_cache +{ + %cmd_cache = (); +} + # # the persistant execution of things from the command directories # diff --git a/perl/DXM.pm b/perl/DXM.pm index 5c735fc7..e92f9f7a 100644 --- a/perl/DXM.pm +++ b/perl/DXM.pm @@ -31,6 +31,7 @@ require Exporter; e1 => 'Invalid command', e2 => 'Error: $_[0]', e3 => '$_[0]: $_[1] not found', + e4 => 'Need at least a prefix or callsign', email => 'E-mail address set to: $_[0]', heres => 'Here set on $_[0]', hereu => 'Here unset on $_[0]', diff --git a/perl/DXUtil.pm b/perl/DXUtil.pm index c82705b7..605bfca4 100644 --- a/perl/DXUtil.pm +++ b/perl/DXUtil.pm @@ -10,7 +10,7 @@ package DXUtil; require Exporter; @ISA = qw(Exporter); -@EXPORT = qw(atime ztime cldate cldatetime slat slong yesno promptf +@EXPORT = qw(atime ztime cldate cldatetime slat slong yesno promptf parray parraypairs print_all_fields ); @@ -102,6 +102,29 @@ sub promptf return ($priv, $prompt); } +# take an arg as an array list and print it +sub parray +{ + return join(', ', @{shift}); +} + +# take the arg as an array reference and print as a list of pairs +sub parraypairs +{ + my $ref = shift; + my $i; + my $out; + + for ($i = 0; $i < @$ref; $i += 2) { + my $r1 = @$ref[$i]; + my $r2 = @$ref[$i+1]; + $out .= "$r1-$r2, "; + } + chop $out; # remove last space + chop $out; # remove last comma + return $out; +} + # print all the fields for a record according to privilege # # The prompt record is of the format ',[,' diff --git a/perl/Prefix.pm b/perl/Prefix.pm index d4ed48b3..b9e235cd 100644 --- a/perl/Prefix.pm +++ b/perl/Prefix.pm @@ -16,9 +16,9 @@ use Data::Dumper; use strict; use vars qw($db %prefix_loc %pre); -local $db; # the DB_File handle -local %prefix_loc; # the meat of the info -local %pre; # the prefix list +$db; # the DB_File handle +%prefix_loc; # the meat of the info +%pre; # the prefix list sub load { diff --git a/perl/Spot.pm b/perl/Spot.pm index 167671dd..64af363e 100644 --- a/perl/Spot.pm +++ b/perl/Spot.pm @@ -109,14 +109,9 @@ sub search $to = $defaultspots; } - $expr =~ s/\$f(\d)/zzzref->[$1]/g; # swap the letter n for the correct field name - $expr =~ s/[\@\$\%\{\}]//g; # remove any other funny characters - $expr =~ s/\&\w+\(//g; # remove subroutine calls - $expr =~ s/eval//g; # remove eval words - $expr =~ s/zzzref/\$ref/g; # put back the $ref - $expr =~ s|(/.+/)|$1oi|g; # add oi characters to /ccc/ + $expr =~ s/\$f(\d)/\$ref->[$1]/g; # swap the letter n for the correct field name - print "expr=($expr), from=$from, to=$to\n"; + dbg("search", "expr='$expr', spotno=$from-$to, day=$dayfrom-$dayto\n"); # build up eval to execute $eval = qq(my \$c; diff --git a/perl/cluster.pl b/perl/cluster.pl index 8a7ae01e..e98dd156 100755 --- a/perl/cluster.pl +++ b/perl/cluster.pl @@ -27,6 +27,7 @@ use DXProt; use DXCluster; use DXDebug; use Prefix; +use Bands; package main; @@ -161,12 +162,19 @@ foreach(@debug) { STDOUT->autoflush(1); # load Prefixes +print "loading prefixes ...\n"; Prefix::load(); +# load band data +print "loading band data ...\n"; +Bands::load(); + # initialise User file system +print "loading user file system ...\n"; DXUser->init($userfn); # start listening for incoming messages/connects +print "starting listener ...\n"; Msg->new_server("$clusteraddr", $clusterport, \&login); # prime some signals @@ -178,6 +186,7 @@ $SIG{'HUP'} = 'IGNORE'; DXProt->init(); # this, such as it is, is the main loop! +print "orft we jolly well go ...\n"; for (;;) { my $timenow; Msg->event_loop(1, 0.001);