perl/Bands.pm

   1 #
   2 # module to manage the band list
   3 #
   4 # Copyright (c) 1998 - Dirk Koopman G1TLH
   5 #
   6 # $Id$
   7 #
   8
   9 package Bands;
  10
  11 use DXUtil;
  12 use DXDebug;
  13 use DXVars;
  14
  15 use strict;
  16 use vars qw(%bands %regions %aliases $bandsfn %valid);
  17
  18 %bands = ();                                    # the 'raw' band data
  19 %regions = ();                                  # list of regions for shortcuts eg vhf ssb
  20 %aliases = ();                                  # list of aliases
  21 $bandsfn = "$main::data/bands.pl";
  22
  23 %valid = (
  24                   cw => '0,CW,parraypairs',
  25                   ssb => '0,SSB,parraypairs',
  26                   data => '0,DATA,parraypairs',
  27                   sstv => '0,SSTV,parraypairs',
  28                   fstv => '0,FSTV,parraypairs',
  29                   rtty => '0,RTTY,parraypairs',
  30                   pactor => '0,PACTOR,parraypairs',
  31                   packet => '0,PACKET,parraypairs',
  32                   repeater => '0,REPEATER,parraypairs',
  33                   fax => '0,FAX,parraypairs',
  34                   beacon => '0,BEACON,parraypairs',
  35                   band => '0,BAND,parraypairs',
  36                  );
  37
  38 use vars qw($VERSION $BRANCH);
  39 $VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ );
  40 $BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/ ) || 0;
  41 $main::build += $VERSION;
  42 $main::branch += $BRANCH;
  43
  44 # load the band data
  45 sub load
  46 {
  47         %bands = ();
  48         do $bandsfn;
  49         confess $@ if $@;
  50 }
  51
  52 # obtain a band object by callsign [$obj = Band::get($call)]
  53 sub get
  54 {
  55         my $call = shift;
  56         my $ncall = $aliases{$call};
  57         $call = $ncall if $ncall;
  58         return $bands{$call};
  59 }
  60
  61 # obtain all the band objects
  62 sub get_all
  63 {
  64         return values(%bands);
  65 }
  66
  67 # get all the band keys
  68 sub get_keys
  69 {
  70         return keys(%bands);
  71 }
  72
  73 # get all the region keys
  74 sub get_region_keys
  75 {
  76         return keys(%regions);
  77 }
  78
  79 # get all the alias keys
  80 sub get_alias_keys
  81 {
  82         return keys(%aliases);
  83 }
  84
  85 # get a region
  86 sub get_region
  87 {
  88         my $reg = shift;
  89         return $regions{$reg};
  90 }
  91
  92 # get all the frequency pairs associated with the band and sub-band offered
  93 # the band can be a region, sub-band can be missing
  94 #
  95 # called Bands::get_freq(band-label, subband-label)
  96 sub get_freq
  97 {
  98         my ($band, $subband) = @_;
  99         my @band;
 100         my $b;
 101         my @out;
 102         return () if !$band;
 103         $subband = 'band' if !$subband;
 104
 105         # first look in the region
 106         $b = $regions{$band};
 107         @band = @$b if $b;
 108         @band = ($band) if @band == 0;
 109
 110         # we now have a list of bands to scan for sub bands
 111         foreach $b (@band) {
 112                 my $wb = $bands{$b};
 113                 if ($wb) {
 114                         my $sb = $wb->{$subband};
 115                         push @out, @$sb if $sb;
 116                 }
 117         }
 118         return @out;
 119 }
 120
 121 #
 122 # return a list of valid elements
 123 #
 124
 125 sub fields
 126 {
 127         return keys(%valid);
 128 }
 129
 130 #
 131 # return a prompt for a field
 132 #
 133
 134 sub field_prompt
 135 {
 136         my ($self, $ele) = @_;
 137         return $valid{$ele};
 138 }
 139
 140 no strict;
 141 sub AUTOLOAD
 142 {
 143         my $self = shift;
 144         my $name = $AUTOLOAD;
 145         return if $name =~ /::DESTROY$/;
 146         $name =~ s/.*:://o;
 147
 148         # this clever line of code creates a subroutine which takes over from autoload
 149         # from OO Perl - Conway
 150         *{$AUTOLOAD} = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}} ;
 151         @_ ? $self->{$name} = shift : $self->{$name} ;
 152 }
 153
 154 1;