From a0cf638d2ec10e9f464bb749cf1b70fd105baf9f Mon Sep 17 00:00:00 2001 From: djk Date: Tue, 10 Nov 1998 21:44:22 +0000 Subject: [PATCH] added the hooks for internationalisation changed CmdAlias so that you manually reload it --- cmd/load/aliases.hlp | 0 cmd/load/aliases.pl | 8 ++ cmd/load/messages.hlp | 0 cmd/load/messages.pl | 8 ++ data/bands.pl | 32 +----- perl/CmdAlias.pm | 39 +++---- perl/DXChannel.pm | 4 +- perl/DXM.pm | 69 ++++++------- perl/DXUser.pm | 1 + perl/DXVars.pm | 4 + perl/cluster.pl | 235 ++++++++++++++++++++++-------------------- 11 files changed, 200 insertions(+), 200 deletions(-) create mode 100644 cmd/load/aliases.hlp create mode 100644 cmd/load/aliases.pl create mode 100644 cmd/load/messages.hlp create mode 100644 cmd/load/messages.pl diff --git a/cmd/load/aliases.hlp b/cmd/load/aliases.hlp new file mode 100644 index 00000000..e69de29b diff --git a/cmd/load/aliases.pl b/cmd/load/aliases.pl new file mode 100644 index 00000000..45a3c165 --- /dev/null +++ b/cmd/load/aliases.pl @@ -0,0 +1,8 @@ +# +# load the Command Aliases file after changing it +# +my $self = shift; +return (0, $self->msg('e5')) if $self->priv < 9; +my @out = CmdAlias::load($self); +@out = ($self->msg('ok')) if !@out; +return (1, @out); diff --git a/cmd/load/messages.hlp b/cmd/load/messages.hlp new file mode 100644 index 00000000..e69de29b diff --git a/cmd/load/messages.pl b/cmd/load/messages.pl new file mode 100644 index 00000000..b8f0dd37 --- /dev/null +++ b/cmd/load/messages.pl @@ -0,0 +1,8 @@ +# +# load the the Messages file after changing it +# +my $self = shift; +return (0, $self->msg('e5')) if $self->priv < 9; +my @out = DXM::load($self); +@out = ($self->msg('ok')) if !@out; +return (1, @out); diff --git a/data/bands.pl b/data/bands.pl index ad7c17f7..71d1fe9d 100644 --- a/data/bands.pl +++ b/data/bands.pl @@ -7,7 +7,7 @@ # these pairs attach themselves to the labels you provide, they are # independant of any other pair, they can overlap, cross etc. # -# There MUST be at least a 'band' entry +# There MUST be at last a 'band' entry # # It is up to YOU to make sure that it makes sense! # @@ -55,15 +55,13 @@ '15m' => bless( { band => [ 21000, 21450 ], cw => [ 21000, 21150 ], data => [ 21100, 21120 ], - beacon => [ 21149, 21151 ], ssb => [ 21151, 21450] }, 'Bands'), - '12m' => bless( { band => [ 24890, 24990 ], - cw => [ 24890, 24820 ], - data => [ 24920, 24929 ], - beacon => [ 24929, 24931 ], - ssb => [ 24931, 24990] + '12m' => bless( { band => [ 21000, 21450 ], + cw => [ 21000, 21150 ], + data => [ 21100, 21120 ], + ssb => [ 21151, 21450] }, 'Bands'), @@ -145,23 +143,3 @@ uhf => [ '70cm', '23cm' ], shf => [ '23cm', '13cm', '9cm', '6cm', '3cm' ], ); - -%aliases = ( - topband => '160m', - 160 => '160m', - 80 => '80m', - 40 => '40m', - 30 => '30m', - 20 => '20m', - 18 => '18m', - 15 => '15m', - 12 => '12m', - 10 => '10m', - 6 => '6m', - 4 => '4m', - 2 => '2m', - 70 => '70cm', - 23 => '23cm', - 13 => '13cm', - 3 => '3cm', -) diff --git a/perl/CmdAlias.pm b/perl/CmdAlias.pm index e5f6686a..8e7f8834 100644 --- a/perl/CmdAlias.pm +++ b/perl/CmdAlias.pm @@ -41,34 +41,31 @@ use Carp; use strict; -use vars qw(%alias $cmd_mtime $localcmd_mtime $fn $localfn); +use vars qw(%alias $fn $localfn); %alias = (); -$cmd_mtime = 1; -$localcmd_mtime = 1; - $fn = "$main::cmd/Aliases"; $localfn = "$main::localcmd/Aliases"; -sub checkfiles +sub load { - my $m = -M $fn; -# print "m: $m oldmtime: $cmd_mtime\n"; - if ($m < $cmd_mtime) { - do $fn; + my $ref = shift; + if (-e $localfn) { + do $localfn; + return ($@) if $@ && ref $ref; + confess $@ if $@; + return (); + } + do $fn; + return ($@) if $@ && ref $ref; confess $@ if $@; - $cmd_mtime = $m; - $localcmd_mtime = 0; - } - if (-e $localfn) { - $m = -M $localfn; - if ($m < $localcmd_mtime) { - do $localfn; - confess $@ if $@; - $localcmd_mtime = $m; - } - } + return (); +} + +sub init +{ + load(); } # @@ -82,8 +79,6 @@ sub get_cmd $let = lc $let; - checkfiles(); - $ref = $alias{$let}; return undef if !$ref; diff --git a/perl/DXChannel.pm b/perl/DXChannel.pm index 9f0db819..3eb387ef 100644 --- a/perl/DXChannel.pm +++ b/perl/DXChannel.pm @@ -76,6 +76,8 @@ sub alloc $self->{startt} = $self->{t} = time; $self->{state} = 0; $self->{oldstate} = 0; + $self->{lang} = $user->{lang} if defined $user; + $self->{lang} = $main::lang if !$self->{lang}; bless $self, $pkg; return $channels{$call} = $self; } @@ -188,7 +190,7 @@ sub send_file sub msg { my $self = shift; - return DXM::msg(@_); + return DXM::msg($self->{lang}, @_); } # change the state of the channel - lots of scope for debugging here :-) diff --git a/perl/DXM.pm b/perl/DXM.pm index 64602a26..5a3b22e3 100644 --- a/perl/DXM.pm +++ b/perl/DXM.pm @@ -17,46 +17,39 @@ package DXM; use DXVars; +use Carp; -%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', - e4 => 'Need at least a prefix or callsign', - e5 => 'Not Allowed', - 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]', - node => '$_[0] set as AK1A style Node', - nodee1 => 'You cannot use this command whilst your target ($_[0]) is on-line', - pr => '$_[0] de $main::mycall $main::cldate $main::ztime >', - priv => 'Privilege level changed on $_[0]', - 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]', -); +my $localfn = "$main::root/local/Messages"; +my $fn = "$main::root/perl/Messages"; sub msg { - my $self = shift; - my $s = $msgs{$self}; - return "unknown message '$self'" if !defined $s; - my $ans = eval qq{ "$s" }; - confess $@ if $@; - return $ans; + my $lang = shift; + my $m = shift; + my $ref = $msgs{$lang}; + my $s = $ref->{$m} if $ref; + return "unknown message '$m' in lang '$lang'" if !defined $s; + my $ans = eval qq{ "$s" }; + confess $@ if $@; + return $ans; +} + +sub load +{ + my $ref = shift; + if (-e $localfn) { + do $localfn; + return ($@) if $@ && ref $ref; + confess $@ if $@; + return (); + } + do $fn; + return ($@) if $@ && ref $ref; + confess $@ if $@; + return (); +} + +sub init +{ + load(); } - diff --git a/perl/DXUser.pm b/perl/DXUser.pm index bc55775f..55245a59 100644 --- a/perl/DXUser.pm +++ b/perl/DXUser.pm @@ -106,6 +106,7 @@ sub new $self->{sort} = 'U'; $self->{dxok} = 1; $self->{annok} = 1; + $self->{lang} = $main::lang; bless $self, $pkg; $u{call} = $self; } diff --git a/perl/DXVars.pm b/perl/DXVars.pm index bac7a6de..145631fd 100644 --- a/perl/DXVars.pm +++ b/perl/DXVars.pm @@ -17,6 +17,7 @@ require Exporter; $clusterport $clusteraddr $debugfn $def_hopcount $data $system $cmd $userfn $motd $local_cmd $mybbsaddr + $lang $pc50_interval, $user_interval ); @@ -48,6 +49,9 @@ $myemail = "djk\@tobit.co.uk"; # Your BBS addr $mybbsaddr = "G1TLH\@GB7TLH.#35.GBR.EU"; +# the default language (the key used must match the one in the Messages file) +$lang = 'en'; + # the tcp address of the cluster this can be an address of an ethernet port # but this is more secure. For normal use this will be fine. $clusteraddr = "localhost"; diff --git a/perl/cluster.pl b/perl/cluster.pl index 7db7ae3c..07c40503 100755 --- a/perl/cluster.pl +++ b/perl/cluster.pl @@ -12,12 +12,12 @@ # make sure that modules are searched in the order local then perl BEGIN { - # root of directory tree for this system - $root = "/spider"; - $root = $ENV{'DXSPIDER_ROOT'} if $ENV{'DXSPIDER_ROOT'}; - - unshift @INC, "$root/perl"; # this IS the right way round! - unshift @INC, "$root/local"; + # root of directory tree for this system + $root = "/spider"; + $root = $ENV{'DXSPIDER_ROOT'} if $ENV{'DXSPIDER_ROOT'}; + + unshift @INC, "$root/perl"; # this IS the right way round! + unshift @INC, "$root/local"; } use Msg; @@ -36,124 +36,128 @@ use DXConnect; use Prefix; use Bands; use Geomag; +use CmdAlias; use Carp; package main; -@inqueue = (); # the main input queue, an array of hashes -$systime = 0; # the time now (in seconds) -$version = 1.2; # the version no of the software +@inqueue = (); # the main input queue, an array of hashes +$systime = 0; # the time now (in seconds) +$version = 1.3; # the version no of the software # handle disconnections sub disconnect { - my $dxchan = shift; - return if !defined $dxchan; - $dxchan->disconnect(); + my $dxchan = shift; + return if !defined $dxchan; + $dxchan->disconnect(); } # handle incoming messages sub rec { - my ($conn, $msg, $err) = @_; - my $dxchan = DXChannel->get_by_cnum($conn); # get the dxconnnect object for this message - - if (defined $err && $err) { - disconnect($dxchan) if defined $dxchan; - return; - } - - # set up the basic channel info - this needs a bit more thought - there is duplication here - if (!defined $dxchan) { - my ($sort, $call, $line) = $msg =~ /^(\w)(\S+)\|(.*)$/; - - # is there one already connected? - if (DXChannel->get($call)) { - my $mess = DXM::msg('conother', $call); - dbg('chan', "-> D $call $mess\n"); - $conn->send_now("D$call|$mess"); - sleep(1); - dbg('chan', "-> Z $call bye\n"); - $conn->send_now("Z$call|bye"); # this will cause 'client' to disconnect - return; - } - - # is there one already connected elsewhere in the cluster? - if (DXCluster->get($call)) { - my $mess = DXM::msg('concluster', $call); - dbg('chan', "-> D $call $mess\n"); - $conn->send_now("D$call|$mess"); - sleep(1); - dbg('chan', "-> Z $call bye\n"); - $conn->send_now("Z$call|bye"); # this will cause 'client' to disconnect - return; - } - - my $user = DXUser->get($call); - if (!defined $user) { - $user = DXUser->new($call); - } - - # create the channel - $dxchan = DXCommandmode->new($call, $conn, $user) if ($user->sort eq 'U'); - $dxchan = DXProt->new($call, $conn, $user) if ($user->sort eq 'A'); - die "Invalid sort of user on $call = $sort" if !$dxchan; - } - - # queue the message and the channel object for later processing - if (defined $msg) { - my $self = bless {}, "inqueue"; - $self->{dxchan} = $dxchan; - $self->{data} = $msg; - push @inqueue, $self; - } + my ($conn, $msg, $err) = @_; + my $dxchan = DXChannel->get_by_cnum($conn); # get the dxconnnect object for this message + + if (defined $err && $err) { + disconnect($dxchan) if defined $dxchan; + return; + } + + # set up the basic channel info - this needs a bit more thought - there is duplication here + if (!defined $dxchan) { + my ($sort, $call, $line) = $msg =~ /^(\w)(\S+)\|(.*)$/; + + # is there one already connected? + if (DXChannel->get($call)) { + my $mess = DXM::msg($lang, 'conother', $call); + dbg('chan', "-> D $call $mess\n"); + $conn->send_now("D$call|$mess"); + sleep(1); + dbg('chan', "-> Z $call bye\n"); + $conn->send_now("Z$call|bye"); # this will cause 'client' to disconnect + return; + } + + # is there one already connected elsewhere in the cluster? + if (DXCluster->get($call)) { + my $mess = DXM::msg($lang, 'concluster', $call); + dbg('chan', "-> D $call $mess\n"); + $conn->send_now("D$call|$mess"); + sleep(1); + dbg('chan', "-> Z $call bye\n"); + $conn->send_now("Z$call|bye"); # this will cause 'client' to disconnect + return; + } + + my $user = DXUser->get($call); + if (!defined $user) { + $user = DXUser->new($call); + } else { + $user->{lang} = $main::lang if !$user->{lang}; # to autoupdate old systems + } + + + # create the channel + $dxchan = DXCommandmode->new($call, $conn, $user) if ($user->sort eq 'U'); + $dxchan = DXProt->new($call, $conn, $user) if ($user->sort eq 'A'); + die "Invalid sort of user on $call = $sort" if !$dxchan; + } + + # queue the message and the channel object for later processing + if (defined $msg) { + my $self = bless {}, "inqueue"; + $self->{dxchan} = $dxchan; + $self->{data} = $msg; + push @inqueue, $self; + } } sub login { - return \&rec; + return \&rec; } # cease running this program, close down all the connections nicely sub cease { - my $dxchan; - foreach $dxchan (DXChannel->get_all()) { - disconnect($dxchan); - } - exit(0); + my $dxchan; + foreach $dxchan (DXChannel->get_all()) { + disconnect($dxchan); + } + exit(0); } # this is where the input queue is dealt with and things are dispatched off to other parts of # the cluster sub process_inqueue { - my $self = shift @inqueue; - return if !$self; - - my $data = $self->{data}; - my $dxchan = $self->{dxchan}; - my ($sort, $call, $line) = $data =~ /^(\w)(\S+)\|(.*)$/; - - # do the really sexy console interface bit! (Who is going to do the TK interface then?) - dbg('chan', "<- $sort $call $line\n"); - - # handle A records - my $user = $dxchan->user; - if ($sort eq 'A') { - $dxchan->start($line); - } elsif ($sort eq 'D') { - die "\$user not defined for $call" if !defined $user; + my $self = shift @inqueue; + return if !$self; + + my $data = $self->{data}; + my $dxchan = $self->{dxchan}; + my ($sort, $call, $line) = $data =~ /^(\w)(\S+)\|(.*)$/; - # normal input - $dxchan->normal($line); - - disconnect($dxchan) if ($dxchan->{state} eq 'bye'); - } elsif ($sort eq 'Z') { - disconnect($dxchan); - } else { - print STDERR atime, " Unknown command letter ($sort) received from $call\n"; - } + # do the really sexy console interface bit! (Who is going to do the TK interface then?) + dbg('chan', "<- $sort $call $line\n"); + + # handle A records + my $user = $dxchan->user; + if ($sort eq 'A') { + $dxchan->start($line); + } elsif ($sort eq 'D') { + die "\$user not defined for $call" if !defined $user; + + # normal input + $dxchan->normal($line); + + disconnect($dxchan) if ($dxchan->{state} eq 'bye'); + } elsif ($sort eq 'Z') { + disconnect($dxchan); + } else { + print STDERR atime, " Unknown command letter ($sort) received from $call\n"; + } } ############################################################# @@ -164,8 +168,8 @@ sub process_inqueue # open the debug file, set various FHs to be unbuffered dbginit($debugfn); -foreach(@debug) { - dbgadd($_); +foreach (@debug) { + dbgadd($_); } STDOUT->autoflush(1); @@ -193,6 +197,12 @@ $SIG{'INT'} = \&cease; $SIG{'TERM'} = \&cease; $SIG{'HUP'} = 'IGNORE'; +# read in system messages +DXM->init(); + +# read in command aliases +CmdAlias->init(); + # initialise the protocol engine DXProt->init(); @@ -216,20 +226,21 @@ DXCron->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); - $timenow = time; - process_inqueue(); # read in lines from the input queue and despatch them - - # do timed stuff, ongoing processing happens one a second - if ($timenow != $systime) { - $systime = $timenow; - $cldate = &cldate(); - $ztime = &ztime(); - DXCommandmode::process(); # process ongoing command mode stuff - DXProt::process(); # process ongoing ak1a pcxx stuff - DXCron::process(); - DXConnect::process(); - } + my $timenow; + Msg->event_loop(1, 0.001); + $timenow = time; + process_inqueue(); # read in lines from the input queue and despatch them + + # do timed stuff, ongoing processing happens one a second + if ($timenow != $systime) { + $systime = $timenow; + $cldate = &cldate(); + $ztime = &ztime(); + DXCommandmode::process(); # process ongoing command mode stuff + DXProt::process(); # process ongoing ak1a pcxx stuff + DXCron::process(); + DXConnect::process(); + } } + -- 2.43.0