perl/DXUtil.pm

   1 #
   2 # various utilities which are exported globally
   3 #
   4 # Copyright (c) 1998 - Dirk Koopman G1TLH
   5 #
   6 # $Id$
   7 #
   8
   9 package DXUtil;
  10
  11 use Date::Parse;
  12 use Carp;
  13
  14 require Exporter;
  15 @ISA = qw(Exporter);
  16 @EXPORT = qw(atime ztime cldate cldatetime slat slong yesno promptf
  17                          parray parraypairs shellregex
  18              print_all_fields cltounix iscallsign
  19             );
  20
  21 @month = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
  22 %patmap = (
  23                    '*' => '.*',
  24                    '?' => '.',
  25                    '[' => '[',
  26                    ']' => ']'
  27 );
  28
  29 # a full time for logging and other purposes
  30 sub atime
  31 {
  32         my $t = shift;
  33         my ($sec,$min,$hour,$mday,$mon,$year) = gmtime((defined $t) ? $t : time);
  34         $year += 1900;
  35         my $buf = sprintf "%02d%s%04d\@%02d:%02d:%02d", $mday, $month[$mon], $year, $hour, $min, $sec;
  36         return $buf;
  37 }
  38
  39 # get a zulu time in cluster format (2300Z)
  40 sub ztime
  41 {
  42         my $t = shift;
  43         my ($sec,$min,$hour) = gmtime((defined $t) ? $t : time);
  44         $year += 1900;
  45         my $buf = sprintf "%02d%02dZ", $hour, $min;
  46         return $buf;
  47
  48 }
  49
  50 # get a cluster format date (23-Jun-1998)
  51 sub cldate
  52 {
  53         my $t = shift;
  54         my ($sec,$min,$hour,$mday,$mon,$year) = gmtime((defined $t) ? $t : time);
  55         $year += 1900;
  56         my $buf = sprintf "%2d-%s-%04d", $mday, $month[$mon], $year;
  57         return $buf;
  58 }
  59
  60 # return a cluster style date time
  61 sub cldatetime
  62 {
  63         my $t = shift;
  64         my $date = cldate($t);
  65         my $time = ztime($t);
  66         return "$date $time";
  67 }
  68
  69 # return a unix date from a cluster date and time
  70 sub cltounix
  71 {
  72         my $date = shift;
  73         my $time = shift;
  74         my ($thisyear) = (gmtime)[5] + 1900;
  75
  76         return 0 unless $date =~ /^\s*(\d+)-(\w\w\w)-([12][90]\d\d)$/;
  77         return 0 if $3 > 2036;
  78         return 0 unless abs($thisyear-$3) <= 1;
  79         $date = "$1 $2 $3";
  80         return 0 unless $time =~ /^([012]\d)([012345]\d)Z$/;
  81         $time = "$1:$2 +0000";
  82         my $r = str2time("$date $time");
  83         return $r unless $r;
  84         return $r == -1 ? undef : $r;
  85 }
  86
  87 # turn a latitude in degrees into a string
  88 sub slat
  89 {
  90         my $n = shift;
  91         my ($deg, $min, $let);
  92         $let = $n >= 0 ? 'N' : 'S';
  93         $n = abs $n;
  94         $deg = int $n;
  95         $min = int ((($n - $deg) * 60) + 0.5);
  96         return "$deg $min $let";
  97 }
  98
  99 # turn a longitude in degrees into a string
 100 sub slong
 101 {
 102         my $n = shift;
 103         my ($deg, $min, $let);
 104         $let = $n >= 0 ? 'E' : 'W';
 105         $n = abs $n;
 106         $deg = int $n;
 107         $min = int ((($n - $deg) * 60) + 0.5);
 108         return "$deg $min $let";
 109 }
 110
 111 # turn a true into 'yes' and false into 'no'
 112 sub yesno
 113 {
 114         my $n = shift;
 115         return $n ? $main::yes : $main::no;
 116 }
 117
 118 # format a prompt with its current value and return it with its privilege
 119 sub promptf
 120 {
 121         my ($line, $value) = @_;
 122         my ($priv, $prompt, $action) = split ',', $line;
 123
 124         # if there is an action treat it as a subroutine and replace $value
 125         if ($action) {
 126                 my $q = qq{\$value = $action(\$value)};
 127                 eval $q;
 128         }
 129         $prompt = sprintf "%15s: %s", $prompt, $value;
 130         return ($priv, $prompt);
 131 }
 132
 133 # take an arg as an array list and print it
 134 sub parray
 135 {
 136         my $ref = shift;
 137         return join(', ', @{$ref});
 138 }
 139
 140 # take the arg as an array reference and print as a list of pairs
 141 sub parraypairs
 142 {
 143         my $ref = shift;
 144         my $i;
 145         my $out;
 146
 147         for ($i = 0; $i < @$ref; $i += 2) {
 148                 my $r1 = @$ref[$i];
 149                 my $r2 = @$ref[$i+1];
 150                 $out .= "$r1-$r2, ";
 151         }
 152         chop $out;                                      # remove last space
 153         chop $out;                                      # remove last comma
 154         return $out;
 155 }
 156
 157 # print all the fields for a record according to privilege
 158 #
 159 # The prompt record is of the format '<priv>,<prompt>[,<action>'
 160 # and is expanded by promptf above
 161 #
 162 sub print_all_fields
 163 {
 164         my $self = shift;                       # is a dxchan
 165         my $ref = shift;                        # is a thingy with field_prompt and fields methods defined
 166         my @out;
 167         my @fields = $ref->fields;
 168         my $field;
 169
 170         foreach $field (sort {$ref->field_prompt($a) cmp $ref->field_prompt($b)} @fields) {
 171                 if (defined $ref->{$field}) {
 172                         my ($priv, $ans) = promptf($ref->field_prompt($field), $ref->{$field});
 173                         push @out, $ans if ($self->priv >= $priv);
 174                 }
 175         }
 176         return @out;
 177 }
 178
 179 # generate a regex from a shell type expression
 180 # see 'perl cookbook' 6.9
 181 sub shellregex
 182 {
 183         my $in = shift;
 184         $in =~ s{(.)} { $patmap{$1} || "\Q$1" }ge;
 185         return '^' . $in . "\$";
 186 }
 187
 188 # start an attempt at determining whether this string might be a callsign
 189 sub iscallsign
 190 {
 191         my $call = shift;
 192         return 1 if $call =~ /^\w+\d+/;
 193         return 1 if $call =~ /^\d+\w+/;
 194         return undef;
 195 }