From a9b7071fedfdb2150f3ef3d74e0d626b4f2dc0ea Mon Sep 17 00:00:00 2001 From: djk Date: Thu, 3 Dec 1998 23:35:58 +0000 Subject: [PATCH] fixed sh/c/n fixed some of the problems with commands and no args fixed sh.* = shutdown fixed set/here doing both cluster and channel added set/beep and made beeps only on user channels (not debug) --- cmd/Aliases | 3 + cmd/announce.pl | 3 + cmd/connect.pl | 6 +- cmd/send.pl | 8 +- cmd/set/here.pl | 8 +- cmd/set/page.pl | 4 +- cmd/show/configuration.pl | 77 ++++-- cmd/talk.pl | 3 + cmd/unset/here.pl | 4 +- perl/DXChannel.pm | 5 +- perl/DXCommandmode.pm | 490 +++++++++++++++++++------------------- perl/DXDebug.pm | 1 + perl/DXProt.pm | 2 + perl/Messages | 6 + 14 files changed, 345 insertions(+), 275 deletions(-) diff --git a/cmd/Aliases b/cmd/Aliases index 8c44c402..bd4f0cab 100644 --- a/cmd/Aliases +++ b/cmd/Aliases @@ -75,6 +75,9 @@ package CmdAlias; '^r$', 'read', 'read', ], s => [ + '^set/nobe', 'unset/beep', 'unset/beep', + '^set/nohe', 'unset/here', 'unset/here', + '^sh/c/n', 'show/configuration nodes', 'show/configuration', '^sh/c$', 'show/configuration', 'show/configuration', '^sh/dx/(\d+)-(\d+)', 'show/dx $1-$2', 'show/dx', '^sh/dx/(\d+)', 'show/dx $1', 'show/dx', diff --git a/cmd/announce.pl b/cmd/announce.pl index f9d3fc4b..4f521dd3 100644 --- a/cmd/announce.pl +++ b/cmd/announce.pl @@ -15,6 +15,9 @@ my ($self, $line) = @_; my @f = split /\s+/, $line; + +return (1, $self->msg('e9')) if !@f; + my $sort = uc $f[0]; my @locals = DXCommandmode->get_all(); my $to; diff --git a/cmd/connect.pl b/cmd/connect.pl index 7fb3b7f4..e1263887 100644 --- a/cmd/connect.pl +++ b/cmd/connect.pl @@ -3,8 +3,12 @@ # my $self = shift; my $call = uc shift; -return (0) if $self->priv < 9; +my $lccall = lc $call; + +return (0) if $self->priv < 8; +return (1, $self->msg('e6')) unless $call gt ' '; return (1, $self->msg('already', $call)) if DXChannel::get($call); +return (1, $self->msg('conscript', $lccall)) unless -e "$main::root/connect/$lccall"; my $prog = "$main::root/local/client.pl"; $prog = "$main::root/perl/client.pl" if ! -e $prog; diff --git a/cmd/send.pl b/cmd/send.pl index a4262285..959a8101 100644 --- a/cmd/send.pl +++ b/cmd/send.pl @@ -25,6 +25,9 @@ my $loc; if ($self->state eq "prompt") { my @f = split /\s+/, $line; + + # any thing after send? + return (1, $self->msg('e6')) if !@f; $f[0] = uc $f[0]; @@ -93,10 +96,9 @@ if ($self->state eq "prompt") { } # check we have some callsigns - if ($i > @f) { + if ($i >= @f) { delete $self->{loc}; - #return (0, $self->msg('esend2')); - return (0, "need a callsign"); + return (1, $self->msg('e6')); } # now save all the 'to' callsigns for later diff --git a/cmd/set/here.pl b/cmd/set/here.pl index 136700f5..52b1c67c 100644 --- a/cmd/set/here.pl +++ b/cmd/set/here.pl @@ -15,9 +15,11 @@ my @out; foreach $call (@args) { $call = uc $call; - my $ref = DXCluster->get($call); - if ($ref) { - $ref->here(1); + my $dxchan = DXChannel->get($call); + my $ref = DXCluster->get_exact($call); + if ($dxchan && $ref) { + $dxchan->here(1); + $ref->here(1); DXProt::broadcast_ak1a(DXProt::pc24($ref)); push @out, $self->msg('heres', $call); } else { diff --git a/cmd/set/page.pl b/cmd/set/page.pl index f7dc64dc..4f76d2a4 100644 --- a/cmd/set/page.pl +++ b/cmd/set/page.pl @@ -7,7 +7,7 @@ # my $self = shift; my $l = shift; -$l = 20 if $l = 0; +$l = 20 if $l == 0; $l = 10 if $l < 10; $self->pagelth($l); -return (1); +return (1, $self->msg('pagelth', $l)); diff --git a/cmd/show/configuration.pl b/cmd/show/configuration.pl index 62beea66..4cd50e26 100644 --- a/cmd/show/configuration.pl +++ b/cmd/show/configuration.pl @@ -11,33 +11,64 @@ my @list = map { uc } split /\s+/, $line; # list of callsigns of nodes my @out; my @nodes = (DXNode::get_all()); my $node; +my @l; +my @val; push @out, "Node Callsigns"; -foreach $node (@nodes) { - if (@list) { - next if !grep $node->call eq $_, @list; - } - my $i = 0; - my @l; - my $call = $node->call; - $call = "($call)" if $node->here == 0; - push @l, $call; - my $nlist = $node->list; - my @val = values %{$nlist}; - foreach $call (@val) { - if ($i >= 5) { - push @out, sprintf "%-12s %-12s %-12s %-12s %-12s %-12s", @l; - @l = (); - push @l, ""; - $i = 0; +if ($list[0] =~ /^NOD/) { + my @ch = DXProt::get_all_ak1a(); + my $dxchan; + + foreach $dxchan (@ch) { + @val = grep { $_->dxchan == $dxchan } @nodes; + my $call = $dxchan->call; + $call = "($call)" if $dxchan->here == 0; + @l = (); + push @l, $call; + + my $i = 0; + foreach $call (@val) { + if ($i >= 5) { + push @out, sprintf "%-12s %-12s %-12s %-12s %-12s %-12s", @l; + @l = (); + push @l, ""; + $i = 0; + } + my $s = $call->{call}; + $s = sprintf "(%s)", $s if $call->{here} == 0; + push @l, $s; + $i++; + } + push @out, sprintf "%-12s %-12s %-12s %-12s %-12s %-12s", @l; + } +} else { + # build up the screen from the Node table + foreach $node (@nodes) { + next if scalar @list && !grep $node->call eq $_, @list; + my $call = $node->call; + $call = "($call)" if $node->here == 0; + @l = (); + push @l, $call; + my $nlist = $node->list; + @val = values %{$nlist}; + + my $i = 0; + foreach $call (@val) { + if ($i >= 5) { + push @out, sprintf "%-12s %-12s %-12s %-12s %-12s %-12s", @l; + @l = (); + push @l, ""; + $i = 0; + } + my $s = $call->{call}; + $s = sprintf "(%s)", $s if $call->{here} == 0; + push @l, $s; + $i++; + } + push @out, sprintf "%-12s %-12s %-12s %-12s %-12s %-12s", @l; } - my $s = $call->{call}; - $s = sprintf "(%s)", $s if $call->{here} == 0; - push @l, $s; - $i++; - } - push @out, sprintf "%-12s %-12s %-12s %-12s %-12s %-12s", @l; } + return (1, @out); diff --git a/cmd/talk.pl b/cmd/talk.pl index a53b213e..4002c828 100644 --- a/cmd/talk.pl +++ b/cmd/talk.pl @@ -12,6 +12,9 @@ my $to = uc $argv[0]; my $via; my $from = $self->call(); +# have we a callsign and some text? +return (1, $self->msg('e8')) if @argv < 2; + if ($argv[1] eq '>') { $via = uc $argv[2]; $line =~ s/^$argv[0]\s+>\s+$argv[2]\s*//; diff --git a/cmd/unset/here.pl b/cmd/unset/here.pl index 48dbae2c..7e299152 100644 --- a/cmd/unset/here.pl +++ b/cmd/unset/here.pl @@ -15,8 +15,10 @@ my @out; foreach $call (@args) { $call = uc $call; + my $dxchan = DXChannel->get($call); my $ref = DXCluster->get($call); - if ($ref) { + if ($dxchan && $ref) { + $dxchan->here(0); $ref->here(0); DXProt::broadcast_ak1a(DXProt::pc24($ref)); push @out, $self->msg('hereu', $call); diff --git a/perl/DXChannel.pm b/perl/DXChannel.pm index 98fa4c61..692bf98b 100644 --- a/perl/DXChannel.pm +++ b/perl/DXChannel.pm @@ -60,6 +60,7 @@ use vars qw(%channels %valid); lang => '0,Language', func => '9,Function', loc => '9,Local Vars', # used by func to store local variables in + beep => '0,Want Beeps,yesno', lastread => '9,Last Msg Read', outbound => '9,outbound?,yesno', remotecmd => '9,doing rcmd,yesno', @@ -152,8 +153,8 @@ sub send_now foreach $line (@_) { chomp $line; - dbg('chan', "-> $sort $call $line\n") if $conn; $conn->send_now("$sort$call|$line") if $conn; + dbg('chan', "-> $sort $call $line") if $conn; } $self->{t} = time; } @@ -170,8 +171,8 @@ sub send # this is always later and always data foreach $line (@_) { chomp $line; - dbg('chan', "-> D $call $line\n") if $conn; $conn->send_later("D$call|$line") if $conn; + dbg('chan', "-> D $call $line") if $conn; } $self->{t} = time; } diff --git a/perl/DXCommandmode.pm b/perl/DXCommandmode.pm index 4ad01392..639820ad 100644 --- a/perl/DXCommandmode.pm +++ b/perl/DXCommandmode.pm @@ -26,10 +26,10 @@ use Carp; use strict; use vars qw(%Cache %cmd_cache $errstr %aliases); -%Cache = (); # cache of dynamically loaded routine's mod times -%cmd_cache = (); # cache of short names -$errstr = (); # error string from eval -%aliases = (); # aliases for (parts of) commands +%Cache = (); # cache of dynamically loaded routine's mod times +%cmd_cache = (); # cache of short names +$errstr = (); # error string from eval +%aliases = (); # aliases for (parts of) commands # # obtain a new connection this is derived from dxchannel @@ -37,9 +37,9 @@ $errstr = (); # error string from eval sub new { - my $self = DXChannel::alloc(@_); - $self->{sort} = 'U'; # in absence of how to find out what sort of an object I am - return $self; + my $self = DXChannel::alloc(@_); + $self->{sort} = 'U'; # in absence of how to find out what sort of an object I am + return $self; } # this is how a a connection starts, you get a hello message and the motd with @@ -48,40 +48,40 @@ sub new sub start { - my ($self, $line, $sort) = @_; - my $user = $self->{user}; - my $call = $self->{call}; - my $name = $user->{name}; - - $self->{name} = $name ? $name : $call; - $self->send($self->msg('l2',$self->{name})); - $self->send_file($main::motd) if (-e $main::motd); - $self->state('prompt'); # a bit of room for further expansion, passwords etc - $self->{priv} = $user->priv; - $self->{lang} = $user->lang; - $self->{pagelth} = 20; - $self->{priv} = 0 if $line =~ /^(ax|te)/; # set the connection priv to 0 - can be upgraded later - $self->{consort} = $line; # save the connection type - - # 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; - - # add yourself to the database - my $node = DXNode->get($main::mycall) or die "$main::mycall not allocated in DXNode database"; - my $cuser = DXNodeuser->new($self, $node, $call, 0, 1); - $node->dxchan($self) if $call eq $main::myalias; # send all output for mycall to myalias - - # issue a pc16 to everybody interested - my $nchan = DXChannel->get($main::mycall); - my @pc16 = DXProt::pc16($nchan, $cuser); - DXProt::broadcast_ak1a(@pc16); - Log('DXCommand', "$call connected"); - - # send prompts and things - my $info = DXCluster::cluster(); - $self->send("Cluster:$info"); - $self->send($self->msg('pr', $call)); + my ($self, $line, $sort) = @_; + my $user = $self->{user}; + my $call = $self->{call}; + my $name = $user->{name}; + + $self->{name} = $name ? $name : $call; + $self->send($self->msg('l2',$self->{name})); + $self->send_file($main::motd) if (-e $main::motd); + $self->state('prompt'); # a bit of room for further expansion, passwords etc + $self->{priv} = $user->priv; + $self->{lang} = $user->lang; + $self->{pagelth} = 20; + $self->{priv} = 0 if $line =~ /^(ax|te)/; # set the connection priv to 0 - can be upgraded later + $self->{consort} = $line; # save the connection type + + # set some necessary flags on the user if they are connecting + $self->{beep} = $self->{wwv} = $self->{talk} = $self->{ann} = $self->{here} = $self->{dx} = 1; + # $self->prompt() if $self->{state} =~ /^prompt/o; + + # add yourself to the database + my $node = DXNode->get($main::mycall) or die "$main::mycall not allocated in DXNode database"; + my $cuser = DXNodeuser->new($self, $node, $call, 0, 1); + $node->dxchan($self) if $call eq $main::myalias; # send all output for mycall to myalias + + # issue a pc16 to everybody interested + my $nchan = DXChannel->get($main::mycall); + my @pc16 = DXProt::pc16($nchan, $cuser); + DXProt::broadcast_ak1a(@pc16); + Log('DXCommand', "$call connected"); + + # send prompts and things + my $info = DXCluster::cluster(); + $self->send("Cluster:$info"); + $self->send($self->msg('pr', $call)); } # @@ -111,10 +111,10 @@ sub normal # send a tranche of data while ($i-- > 0 && @$ref) { my $line = shift @$ref; - $line =~ s/\s+$//o; # why am having to do this? + $line =~ s/\s+$//o; # why am having to do this? $self->send($line); } - + # reset state if none or else chuck out an intermediate prompt if ($ref && @$ref) { $tot -= $self->{pagelth}; @@ -124,12 +124,12 @@ sub normal } } else { @ans = run_cmd($self, $cmdline) if length $cmdline; - + if ($self->{pagelth} && @ans > $self->{pagelth}) { my $i; for ($i = $self->{pagelth}; $i-- > 0; ) { my $line = shift @ans; - $line =~ s/\s+$//o; # why am having to do this? + $line =~ s/\s+$//o; # why am having to do this? $self->send($line); } $self->{pagedata} = \@ans; @@ -137,7 +137,7 @@ sub normal $self->send($self->msg('page', scalar @ans)); } else { for (@ans) { - s/\s+$//o; # why ????????? + s/\s+$//o; # why ????????? $self->send($_); } } @@ -173,26 +173,33 @@ sub run_cmd $cmdline =~ s|//|/|og; # split the command line up into parts, the first part is the command - my ($cmd, $args) = $cmdline =~ /^([\w\/]+)\s*(.*)/o; + my ($cmd, $args) = $cmdline =~ /^([\S\/]+)\s*(.*)/o; if ($cmd) { my ($path, $fcmd); + dbg('command', "cmd: $cmd"); + # alias it if possible my $acmd = CmdAlias::get_cmd($cmd); if ($acmd) { ($cmd, $args) = "$acmd $args" =~ /^([\w\/]+)\s*(.*)/o; + dbg('command', "aliased cmd: $cmd $args"); } # first expand out the entry to a command ($path, $fcmd) = search($main::localcmd, $cmd, "pl"); ($path, $fcmd) = search($main::cmd, $cmd, "pl") if !$path || !$fcmd; + + dbg('command', "path: $cmd cmd: $fcmd"); my $package = find_cmd_name($path, $fcmd); @ans = (0) if !$package ; if ($package) { + dbg('command', "package: $package"); + my $c = qq{ \@ans = $package(\$self, \$args) }; dbg('eval', "cluster cmd = $c\n"); eval $c; @@ -202,7 +209,7 @@ sub run_cmd } } } - + if ($ans[0]) { shift @ans; } else { @@ -222,19 +229,19 @@ sub run_cmd # sub process { - my $t = time; - my @chan = DXChannel->get_all(); - my $chan; - - foreach $chan (@chan) { - next if $chan->sort ne 'U'; - - # send a prompt if no activity out on this channel - if ($t >= $chan->t + $main::user_interval) { - $chan->prompt() if $chan->{state} =~ /^prompt/o; - $chan->t($t); + my $t = time; + my @chan = DXChannel->get_all(); + my $chan; + + foreach $chan (@chan) { + next if $chan->sort ne 'U'; + + # send a prompt if no activity out on this channel + if ($t >= $chan->t + $main::user_interval) { + $chan->prompt() if $chan->{state} =~ /^prompt/o; + $chan->t($t); + } } - } } # @@ -242,22 +249,22 @@ sub process # sub finish { - my $self = shift; - my $call = $self->call; - - if ($call eq $main::myalias) { # unset the channel if it is us really - my $node = DXNode->get($main::mycall); - $node->{dxchan} = 0; - } - my $ref = DXNodeuser->get($call); - - # issue a pc17 to everybody interested - my $nchan = DXChannel->get($main::mycall); - my $pc17 = $nchan->pc17($self); - DXProt::broadcast_ak1a($pc17); - - Log('DXCommand', "$call disconnected"); - $ref->del() if $ref; + my $self = shift; + my $call = $self->call; + + if ($call eq $main::myalias) { # unset the channel if it is us really + my $node = DXNode->get($main::mycall); + $node->{dxchan} = 0; + } + my $ref = DXNodeuser->get($call); + + # issue a pc17 to everybody interested + my $nchan = DXChannel->get($main::mycall); + my $pc17 = $nchan->pc17($self); + DXProt::broadcast_ak1a($pc17); + + Log('DXCommand', "$call disconnected"); + $ref->del() if $ref; } # @@ -266,40 +273,40 @@ sub finish sub prompt { - my $self = shift; - my $call = $self->{call}; - $self->send($self->msg('pr', $call)); - #DXChannel::msg($self, 'pr', $call); + my $self = shift; + my $call = $self->{call}; + $self->send($self->msg('pr', $call)); + #DXChannel::msg($self, 'pr', $call); } # broadcast a message to all users [except those mentioned after buffer] sub broadcast { - my $pkg = shift; # ignored - my $s = shift; # the line to be rebroadcast - my @except = @_; # to all channels EXCEPT these (dxchannel refs) - my @list = DXChannel->get_all(); # just in case we are called from some funny object - my ($chan, $except); - -L: foreach $chan (@list) { - next if !$chan->sort eq 'U'; # only interested in user channels - foreach $except (@except) { - next L if $except == $chan; # ignore channels in the 'except' list - } - chan->send($s); # send it - } + my $pkg = shift; # ignored + my $s = shift; # the line to be rebroadcast + my @except = @_; # to all channels EXCEPT these (dxchannel refs) + my @list = DXChannel->get_all(); # just in case we are called from some funny object + my ($chan, $except); + + L: foreach $chan (@list) { + next if !$chan->sort eq 'U'; # only interested in user channels + foreach $except (@except) { + next L if $except == $chan; # ignore channels in the 'except' list + } + chan->send($s); # send it + } } # gimme all the users sub get_all { - my @list = DXChannel->get_all(); - my $ref; - my @out; - foreach $ref (@list) { - push @out, $ref if $ref->sort eq 'U'; - } - return @out; + my @list = DXChannel->get_all(); + my $ref; + my @out; + foreach $ref (@list) { + push @out, $ref if $ref->sort eq 'U'; + } + return @out; } # @@ -308,64 +315,67 @@ sub get_all sub search { - 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 not guess - my @parts = split '/', $short_cmd; - my $dirfn; - my $curdir = $path; - my $p; - my $i; - my @lparts; - - 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 - @lparts = split /\./, $l; - next if $lparts[$#lparts] ne $suffix; # only look for .$suffix files - if ($p eq substr($l, 0, length $p)) { - pop @lparts; # remove the suffix - $l = join '.', @lparts; -# 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"); + my ($path, $short_cmd, $suffix) = @_; + my ($apath, $acmd); + + # commands are lower case + $short_cmd = lc $short_cmd; + dbg('command', "command: $path $short_cmd\n"); + + # do some checking for funny characters + return () if $short_cmd =~ /\/$/; + + # 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 not guess + my @parts = split '/', $short_cmd; + my $dirfn; + my $curdir = $path; + my $p; + my $i; + my @lparts; + + 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 + @lparts = split /\./, $l; + next if $lparts[$#lparts] ne $suffix; # only look for .$suffix files + if ($p eq substr($l, 0, length $p)) { + pop @lparts; # remove the suffix + $l = join '.', @lparts; + # 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 (); + return (); } # clear the command name cache sub clear_cmd_cache { - %cmd_cache = (); + %cmd_cache = (); } # @@ -380,30 +390,30 @@ sub clear_cmd_cache #require Devel::Symdump; sub valid_package_name { - my($string) = @_; - $string =~ s/([^A-Za-z0-9\/])/sprintf("_%2x",unpack("C",$1))/eg; - - #second pass only for words starting with a digit - $string =~ s|/(\d)|sprintf("/_%2x",unpack("C",$1))|eg; + my($string) = @_; + $string =~ s/([^A-Za-z0-9\/])/sprintf("_%2x",unpack("C",$1))/eg; - #Dress it up as a real package name - $string =~ s/\//_/og; - return "Emb_" . $string; + #second pass only for words starting with a digit + $string =~ s|/(\d)|sprintf("/_%2x",unpack("C",$1))|eg; + + #Dress it up as a real package name + $string =~ s/\//_/og; + return "Emb_" . $string; } #borrowed from Safe.pm sub delete_package { - my $pkg = shift; - my ($stem, $leaf); + my $pkg = shift; + my ($stem, $leaf); + + no strict 'refs'; + $pkg = "DXCommandmode::$pkg\::"; # expand to full symbol table name + ($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/; - no strict 'refs'; - $pkg = "DXCommandmode::$pkg\::"; # expand to full symbol table name - ($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/; - - if ($stem && $leaf) { - my $stem_symtab = *{$stem}{HASH}; - delete $stem_symtab->{$leaf}; - } + if ($stem && $leaf) { + my $stem_symtab = *{$stem}{HASH}; + delete $stem_symtab->{$leaf}; + } } # find a cmd reference @@ -416,87 +426,87 @@ sub delete_package { # sub find_cmd_ref { - my $cmd = shift; - my $r; - - if ($cmd) { - - # first expand out the entry to a command - my ($path, $fcmd) = search($main::localcmd, $cmd, "pl"); - ($path, $fcmd) = search($main::cmd, $cmd, "pl") if !$path || !$fcmd; - - # make sure it is loaded - $r = find_cmd_name($path, $fcmd); - } - return $r; + my $cmd = shift; + my $r; + + if ($cmd) { + + # first expand out the entry to a command + my ($path, $fcmd) = search($main::localcmd, $cmd, "pl"); + ($path, $fcmd) = search($main::cmd, $cmd, "pl") if !$path || !$fcmd; + + # make sure it is loaded + $r = find_cmd_name($path, $fcmd); + } + return $r; } # # this bit of magic finds a command in the offered directory sub find_cmd_name { - my $path = shift; - my $cmdname = shift; - my $package = valid_package_name($cmdname); - my $filename = "$path/$cmdname.pl"; - my $mtime = -M $filename; - - # return if we can't find it - $errstr = undef; - if (undef $mtime) { - $errstr = DXM::msg('e1'); - return undef; - } - - if(defined $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"; - ; - } else { - my $fh = new FileHandle; - if (!open $fh, $filename) { - $errstr = "Syserr: can't open '$filename' $!"; - return undef; - }; - local $/ = undef; - my $sub = <$fh>; - close $fh; - - #wrap the code into a subroutine inside our unique package - my $eval = qq{ - sub $package - { - $sub - } }; - - if (isdbg('eval')) { - my @list = split /\n/, $eval; - my $line; - for (@list) { - dbg('eval', $_, "\n"); - } - } + my $path = shift; + my $cmdname = shift; + my $package = valid_package_name($cmdname); + my $filename = "$path/$cmdname.pl"; + my $mtime = -M $filename; - { - #hide our variables within this block - my($filename,$mtime,$package,$sub); - eval $eval; + # return if we can't find it + $errstr = undef; + if (undef $mtime) { + $errstr = DXM::msg('e1'); + return undef; } - if ($@) { - print "\$\@ = $@"; - $errstr = $@; - delete_package($package); + if(defined $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"; + ; } else { - #cache it unless we're cleaning out each time - $Cache{$package}{mtime} = $mtime; + my $fh = new FileHandle; + if (!open $fh, $filename) { + $errstr = "Syserr: can't open '$filename' $!"; + return undef; + }; + local $/ = undef; + my $sub = <$fh>; + close $fh; + + #wrap the code into a subroutine inside our unique package + my $eval = qq{ + sub $package + { + $sub + } }; + + if (isdbg('eval')) { + my @list = split /\n/, $eval; + my $line; + for (@list) { + dbg('eval', $_, "\n"); + } + } + + { + #hide our variables within this block + my($filename,$mtime,$package,$sub); + eval $eval; + } + + if ($@) { + print "\$\@ = $@"; + $errstr = $@; + delete_package($package); + } else { + #cache it unless we're cleaning out each time + $Cache{$package}{mtime} = $mtime; + } } - } - - #print Devel::Symdump->rnew($package)->as_string, $/; - $package = "DXCommandmode::$package" if $package; - $package = undef if $errstr; - return $package; + + #print Devel::Symdump->rnew($package)->as_string, $/; + $package = "DXCommandmode::$package" if $package; + $package = undef if $errstr; + return $package; } 1; diff --git a/perl/DXDebug.pm b/perl/DXDebug.pm index ecf4c129..96cc0ec2 100644 --- a/perl/DXDebug.pm +++ b/perl/DXDebug.pm @@ -33,6 +33,7 @@ sub dbg if ($dbglevel{$l}) { for (@_) { s/\n$//og; + s/\a//og; # beeps } print "@_\n" if defined \*STDOUT; my $t = time; diff --git a/perl/DXProt.pm b/perl/DXProt.pm index ec49fedd..5fb68418 100644 --- a/perl/DXProt.pm +++ b/perl/DXProt.pm @@ -38,6 +38,7 @@ sub init { my $user = DXUser->get($main::mycall); $me = DXProt->new($main::mycall, undef, $user); + $me->{here} = 1; # $me->{sort} = 'M'; # M for me } @@ -606,6 +607,7 @@ sub broadcast_users foreach $chan (@chan) { next if grep $chan == $_, @except; + $s =~ s/\a//og if !$chan->{beep}; $chan->send($s); # send it if it isn't the except list } } diff --git a/perl/Messages b/perl/Messages index 3709b2dd..ded68412 100644 --- a/perl/Messages +++ b/perl/Messages @@ -14,8 +14,11 @@ package DXM; already => '$_[0] already connnected', anns => 'Announce flag set on $_[0]', annu => 'Announce flag unset on $_[0]', + beepoff => 'Beeps are now off', + beepon => 'Beeps are now on', conother => 'Sorry $_[0] you are connected on another port', concluster => 'Sorry $_[0] you are already connected elsewhere on the cluster', + conscript => 'no connect script called \"$_[0]\" found in $main::root/connect', confail => 'connection to $_[0] failed ($_[1])', constart => 'connection to $_[0] started', dx1 => 'Frequency $_[0] not in band [usage: DX freq call comments](see sh/band)', @@ -29,6 +32,8 @@ package DXM; e5 => 'Not Allowed', e6 => 'Need a callsign', e7 => 'callsign $_[0] not visible on the cluster', + e8 => 'Need a callsign and some text', + e9 => 'Need at least some text', email => 'E-mail address set to: $_[0]', heres => 'Here set on $_[0]', hereu => 'Here unset on $_[0]', @@ -42,6 +47,7 @@ package DXM; nodee1 => 'You cannot use this command whilst your target ($_[0]) is on-line', ok => 'Operation successful', page => 'Press Enter to continue, A to abort ($_[0] lines) >', + pagelth => 'Page Length is now $_[0]', pingo => 'Ping Started to $_[0]', pingi => 'Ping Returned from $_[0] ($_[2] secs)', pr => '$_[0] de $main::mycall $main::cldate $main::ztime >', -- 2.43.0