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 parray parraypairs
  17              print_all_fields cltounix
  18             );
  19
  20 @month = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
  21
  22 # a full time for logging and other purposes
  23 sub atime
  24 {
  25         my $t = shift;
  26         my ($sec,$min,$hour,$mday,$mon,$year) = gmtime((defined $t) ? $t : time);
  27         $year += 1900;
  28         my $buf = sprintf "%02d%s%04d\@%02d:%02d:%02d", $mday, $month[$mon], $year, $hour, $min, $sec;
  29         return $buf;
  30 }
  31
  32 # get a zulu time in cluster format (2300Z)
  33 sub ztime
  34 {
  35         my $t = shift;
  36         my ($sec,$min,$hour) = gmtime((defined $t) ? $t : time);
  37         $year += 1900;
  38         my $buf = sprintf "%02d%02dZ", $hour, $min;
  39         return $buf;
  40
  41 }
  42
  43 # get a cluster format date (23-Jun-1998)
  44 sub cldate
  45 {
  46         my $t = shift;
  47         my ($sec,$min,$hour,$mday,$mon,$year) = gmtime((defined $t) ? $t : time);
  48         $year += 1900;
  49         my $buf = sprintf "%2d-%s-%04d", $mday, $month[$mon], $year;
  50         return $buf;
  51 }
  52
  53 # return a cluster style date time
  54 sub cldatetime
  55 {
  56         my $t = shift;
  57         my $date = cldate($t);
  58         my $time = ztime($t);
  59         return "$date $time";
  60 }
  61
  62 # return a unix date from a cluster date and time
  63 sub cltounix
  64 {
  65         my $date = shift;
  66         my $time = shift;
  67         my ($thisyear) = (gmtime)[5] + 1900;
  68
  69         return 0 unless $date =~ /^\s*(\d+)-(\w\w\w)-([12][90]\d\d)$/;
  70         return 0 if $3 > 2036;
  71         return 0 unless abs($thisyear-$3) <= 1;
  72         $date = "$1 $2 $3";
  73         return 0 unless $time =~ /^([012]\d)([012345]\d)Z$/;
  74         $time = "$1:$2 +0000";
  75         return str2time("$date $time");
  76 }
  77
  78 # turn a latitude in degrees into a string
  79 sub slat
  80 {
  81         my $n = shift;
  82         my ($deg, $min, $let);
  83         $let = $n >= 0 ? 'N' : 'S';
  84         $n = abs $n;
  85         $deg = int $n;
  86         $min = int ((($n - $deg) * 60) + 0.5);
  87         return "$deg $min $let";
  88 }
  89
  90 # turn a longitude in degrees into a string
  91 sub slong
  92 {
  93         my $n = shift;
  94         my ($deg, $min, $let);
  95         $let = $n >= 0 ? 'E' : 'W';
  96         $n = abs $n;
  97         $deg = int $n;
  98         $min = int ((($n - $deg) * 60) + 0.5);
  99         return "$deg $min $let";
 100 }
 101
 102 # turn a true into 'yes' and false into 'no'
 103 sub yesno
 104 {
 105         my $n = shift;
 106         return $n ? $main::yes : $main::no;
 107 }
 108
 109 # format a prompt with its current value and return it with its privilege
 110 sub promptf
 111 {
 112         my ($line, $value) = @_;
 113         my ($priv, $prompt, $action) = split ',', $line;
 114
 115         # if there is an action treat it as a subroutine and replace $value
 116         if ($action) {
 117                 my $q = qq{\$value = $action(\$value)};
 118                 eval $q;
 119         }
 120         $prompt = sprintf "%15s: %s", $prompt, $value;
 121         return ($priv, $prompt);
 122 }
 123
 124 # take an arg as an array list and print it
 125 sub parray
 126 {
 127         my $ref = shift;
 128         return join(', ', @{$ref});
 129 }
 130
 131 # take the arg as an array reference and print as a list of pairs
 132 sub parraypairs
 133 {
 134         my $ref = shift;
 135         my $i;
 136         my $out;
 137
 138         for ($i = 0; $i < @$ref; $i += 2) {
 139                 my $r1 = @$ref[$i];
 140                 my $r2 = @$ref[$i+1];
 141                 $out .= "$r1-$r2, ";
 142         }
 143         chop $out;                                      # remove last space
 144         chop $out;                                      # remove last comma
 145         return $out;
 146 }
 147
 148 # print all the fields for a record according to privilege
 149 #
 150 # The prompt record is of the format '<priv>,<prompt>[,<action>'
 151 # and is expanded by promptf above
 152 #
 153 sub print_all_fields
 154 {
 155         my $self = shift;                       # is a dxchan
 156         my $ref = shift;                        # is a thingy with field_prompt and fields methods defined
 157         my @out;
 158         my @fields = $ref->fields;
 159         my $field;
 160
 161         foreach $field (sort @fields) {
 162                 if (defined $ref->{$field}) {
 163                         my ($priv, $ans) = promptf($ref->field_prompt($field), $ref->{$field});
 164                         push @out, $ans if ($self->priv >= $priv);
 165                 }
 166         }
 167         return @out;
 168 }
 169