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